home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / t / op / taint.t < prev    next >
Text File  |  1998-07-03  |  16KB  |  591 lines
  1. #!./perl -T
  2. #
  3. # Taint tests by Tom Phoenix <rootbeer@teleport.com>.
  4. #
  5. # I don't claim to know all about tainting. If anyone sees
  6. # tests that I've missed here, please add them. But this is
  7. # better than having no tests at all, right?
  8. #
  9.  
  10. BEGIN {
  11.     chdir 't' if -d 't';
  12.     @INC = '../lib' if -d '../lib';
  13. }
  14.  
  15. use strict;
  16. use Config;
  17.  
  18. my $Is_VMS = $^O eq 'VMS';
  19. my $Is_MSWin32 = $^O eq 'MSWin32';
  20. my $Is_Dos = $^O eq 'dos';
  21. my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' :
  22.                   $Is_MSWin32 ? '.\perl' : './perl';
  23. my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/;
  24.  
  25. if ($Is_VMS) {
  26.     my (%old, $x);
  27.     for $x ('DCL$PATH', @MoreEnv) {
  28.     ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x};
  29.     }
  30.     eval <<EndOfCleanup;
  31.     END {
  32.         \$ENV{PATH} = '';
  33.         warn "# Note: logical name 'PATH' may have been deleted\n";
  34.         @ENV{keys %old} = values %old;
  35.     }
  36. EndOfCleanup
  37. }
  38.  
  39. # Sources of taint:
  40. #   The empty tainted value, for tainting strings
  41. my $TAINT = substr($^X, 0, 0);
  42. #   A tainted zero, useful for tainting numbers
  43. my $TAINT0 = 0 + $TAINT;
  44.  
  45. # This taints each argument passed. All must be lvalues.
  46. # Side effect: It also stringifies them. :-(
  47. sub taint_these (@) {
  48.     for (@_) { $_ .= $TAINT }
  49. }
  50.  
  51. # How to identify taint when you see it
  52. sub any_tainted (@) {
  53.     not eval { join("",@_), kill 0; 1 };
  54. }
  55. sub tainted ($) {
  56.     any_tainted @_;
  57. }
  58. sub all_tainted (@) {
  59.     for (@_) { return 0 unless tainted $_ }
  60.     1;
  61. }
  62.  
  63. sub test ($$;$) {
  64.     my($serial, $boolean, $diag) = @_;
  65.     if ($boolean) {
  66.     print "ok $serial\n";
  67.     } else {
  68.     print "not ok $serial\n";
  69.     for (split m/^/m, $diag) {
  70.         print "# $_";
  71.     }
  72.     print "\n" unless
  73.         $diag eq ''
  74.         or substr($diag, -1) eq "\n";
  75.     }
  76. }
  77.  
  78. # We need an external program to call.
  79. my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$");
  80. END { unlink $ECHO }
  81. open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
  82. print PROG 'print "@ARGV\n"', "\n";
  83. close PROG;
  84. my $echo = "$Invoke_Perl $ECHO";
  85.  
  86. print "1..149\n";
  87.  
  88. # First, let's make sure that Perl is checking the dangerous
  89. # environment variables. Maybe they aren't set yet, so we'll
  90. # taint them ourselves.
  91. {
  92.     $ENV{'DCL$PATH'} = '' if $Is_VMS;
  93.  
  94.     $ENV{PATH} = '';
  95.     delete @ENV{@MoreEnv};
  96.     $ENV{TERM} = 'dumb';
  97.  
  98.     test 1, eval { `$echo 1` } eq "1\n";
  99.  
  100.     if ($Is_MSWin32 || $Is_VMS || $Is_Dos) {
  101.     print "# Environment tainting tests skipped\n";
  102.     for (2..5) { print "ok $_\n" }
  103.     }
  104.     else {
  105.     my @vars = ('PATH', @MoreEnv);
  106.     while (my $v = $vars[0]) {
  107.         local $ENV{$v} = $TAINT;
  108.         last if eval { `$echo 1` };
  109.         last unless $@ =~ /^Insecure \$ENV{$v}/;
  110.         shift @vars;
  111.     }
  112.     test 2, !@vars, "\$$vars[0]";
  113.  
  114.     # tainted $TERM is unsafe only if it contains metachars
  115.     local $ENV{TERM};
  116.     $ENV{TERM} = 'e=mc2';
  117.     test 3, eval { `$echo 1` } eq "1\n";
  118.     $ENV{TERM} = 'e=mc2' . $TAINT;
  119.     test 4, eval { `$echo 1` } eq '';
  120.     test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@;
  121.     }
  122.  
  123.     my $tmp;
  124.     if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) {
  125.     print "# all directories are writeable\n";
  126.     }
  127.     else {
  128.     $tmp = (grep { defined and -d and (stat _)[2] & 2 }
  129.              qw(/tmp /var/tmp /usr/tmp /sys$scratch),
  130.              @ENV{qw(TMP TEMP)})[0]
  131.         or print "# can't find world-writeable directory to test PATH\n";
  132.     }
  133.  
  134.     if ($tmp) {
  135.     local $ENV{PATH} = $tmp;
  136.     test 6, eval { `$echo 1` } eq '';
  137.     test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
  138.     }
  139.     else {
  140.     for (6..7) { print "ok $_ # Skipped: all directories are writeable\n" }
  141.     }
  142.  
  143.     if ($Is_VMS) {
  144.     $ENV{'DCL$PATH'} = $TAINT;
  145.     test 8,  eval { `$echo 1` } eq '';
  146.     test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
  147.     if ($tmp) {
  148.         $ENV{'DCL$PATH'} = $tmp;
  149.         test 10, eval { `$echo 1` } eq '';
  150.         test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@;
  151.     }
  152.     else {
  153.         for (10..11) { print "ok $_ # Skipped: can't find world-writeable directory to test DCL\$PATH\n" }
  154.     }
  155.     $ENV{'DCL$PATH'} = '';
  156.     }
  157.     else {
  158.     for (8..11) { print "ok $_ # Skipped: This is not VMS\n"; }
  159.     }
  160. }
  161.  
  162. # Let's see that we can taint and untaint as needed.
  163. {
  164.     my $foo = $TAINT;
  165.     test 12, tainted $foo;
  166.  
  167.     # That was a sanity check. If it failed, stop the insanity!
  168.     die "Taint checks don't seem to be enabled" unless tainted $foo;
  169.  
  170.     $foo = "foo";
  171.     test 13, not tainted $foo;
  172.  
  173.     taint_these($foo);
  174.     test 14, tainted $foo;
  175.  
  176.     my @list = 1..10;
  177.     test 15, not any_tainted @list;
  178.     taint_these @list[1,3,5,7,9];
  179.     test 16, any_tainted @list;
  180.     test 17, all_tainted @list[1,3,5,7,9];
  181.     test 18, not any_tainted @list[0,2,4,6,8];
  182.  
  183.     ($foo) = $foo =~ /(.+)/;
  184.     test 19, not tainted $foo;
  185.  
  186.     $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
  187.     test 20, not tainted $foo;
  188.     test 21, $foo eq 'bar';
  189.  
  190.     {
  191.       use re 'taint';
  192.  
  193.       ($foo) = ('bar' . $TAINT) =~ /(.+)/;
  194.       test 22, tainted $foo;
  195.       test 23, $foo eq 'bar';
  196.  
  197.       $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
  198.       test 24, tainted $foo;
  199.       test 25, $foo eq 'bar';
  200.     }
  201.  
  202.     $foo = $1 if 'bar' =~ /(.+)$TAINT/;
  203.     test 26, tainted $foo;
  204.     test 27, $foo eq 'bar';
  205.  
  206.     my $pi = 4 * atan2(1,1) + $TAINT0;
  207.     test 28, tainted $pi;
  208.  
  209.     ($pi) = $pi =~ /(\d+\.\d+)/;
  210.     test 29, not tainted $pi;
  211.     test 30, sprintf("%.5f", $pi) eq '3.14159';
  212. }
  213.  
  214. # How about command-line arguments? The problem is that we don't
  215. # always get some, so we'll run another process with some.
  216. {
  217.     my $arg = "./arg$$";
  218.     open PROG, "> $arg" or die "Can't create $arg: $!";
  219.     print PROG q{
  220.     eval { join('', @ARGV), kill 0 };
  221.     exit 0 if $@ =~ /^Insecure dependency/;
  222.     print "# Oops: \$@ was [$@]\n";
  223.     exit 1;
  224.     };
  225.     close PROG;
  226.     print `$Invoke_Perl "-T" $arg and some suspect arguments`;
  227.     test 31, !$?, "Exited with status $?";
  228.     unlink $arg;
  229. }
  230.  
  231. # Reading from a file should be tainted
  232. {
  233.     my $file = './TEST';
  234.     test 32, open(FILE, $file), "Couldn't open '$file': $!";
  235.  
  236.     my $block;
  237.     sysread(FILE, $block, 100);
  238.     my $line = <FILE>;
  239.     close FILE;
  240.     test 33, tainted $block;
  241.     test 34, tainted $line;
  242. }
  243.  
  244. # Globs should be forbidden, except under VMS,
  245. #   which doesn't spawn an external program.
  246. if ($Is_VMS) {
  247.     for (35..36) { print "ok $_\n"; }
  248. }
  249. else {
  250.     my @globs = eval { <*> };
  251.     test 35, @globs == 0 && $@ =~ /^Insecure dependency/;
  252.  
  253.     @globs = eval { glob '*' };
  254.     test 36, @globs == 0 && $@ =~ /^Insecure dependency/;
  255. }
  256.  
  257. # Output of commands should be tainted
  258. {
  259.     my $foo = `$echo abc`;
  260.     test 37, tainted $foo;
  261. }
  262.  
  263. # Certain system variables should be tainted
  264. {
  265.     test 38, all_tainted $^X, $0;
  266. }
  267.  
  268. # Results of matching should all be untainted
  269. {
  270.     my $foo = "abcdefghi" . $TAINT;
  271.     test 39, tainted $foo;
  272.  
  273.     $foo =~ /def/;
  274.     test 40, not any_tainted $`, $&, $';
  275.  
  276.     $foo =~ /(...)(...)(...)/;
  277.     test 41, not any_tainted $1, $2, $3, $+;
  278.  
  279.     my @bar = $foo =~ /(...)(...)(...)/;
  280.     test 42, not any_tainted @bar;
  281.  
  282.     test 43, tainted $foo;    # $foo should still be tainted!
  283.     test 44, $foo eq "abcdefghi";
  284. }
  285.  
  286. # Operations which affect files can't use tainted data.
  287. {
  288.     test 45, eval { chmod 0, $TAINT } eq '', 'chmod';
  289.     test 46, $@ =~ /^Insecure dependency/, $@;
  290.  
  291.     # There is no feature test in $Config{} for truncate,
  292.     #   so we allow for the possibility that it's missing.
  293.     test 47, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
  294.     test 48, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
  295.  
  296.     test 49, eval { rename '', $TAINT } eq '', 'rename';
  297.     test 50, $@ =~ /^Insecure dependency/, $@;
  298.  
  299.     test 51, eval { unlink $TAINT } eq '', 'unlink';
  300.     test 52, $@ =~ /^Insecure dependency/, $@;
  301.  
  302.     test 53, eval { utime $TAINT } eq '', 'utime';
  303.     test 54, $@ =~ /^Insecure dependency/, $@;
  304.  
  305.     if ($Config{d_chown}) {
  306.     test 55, eval { chown -1, -1, $TAINT } eq '', 'chown';
  307.     test 56, $@ =~ /^Insecure dependency/, $@;
  308.     }
  309.     else {
  310.     for (55..56) { print "ok $_ # Skipped: chown() is not available\n" }
  311.     }
  312.  
  313.     if ($Config{d_link}) {
  314.     test 57, eval { link $TAINT, '' } eq '', 'link';
  315.     test 58, $@ =~ /^Insecure dependency/, $@;
  316.     }
  317.     else {
  318.     for (57..58) { print "ok $_ # Skipped: link() is not available\n" }
  319.     }
  320.  
  321.     if ($Config{d_symlink}) {
  322.     test 59, eval { symlink $TAINT, '' } eq '', 'symlink';
  323.     test 60, $@ =~ /^Insecure dependency/, $@;
  324.     }
  325.     else {
  326.     for (59..60) { print "ok $_ # Skipped: symlink() is not available\n" }
  327.     }
  328. }
  329.  
  330. # Operations which affect directories can't use tainted data.
  331. {
  332.     test 61, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
  333.     test 62, $@ =~ /^Insecure dependency/, $@;
  334.  
  335.     test 63, eval { rmdir $TAINT } eq '', 'rmdir';
  336.     test 64, $@ =~ /^Insecure dependency/, $@;
  337.  
  338.     test 65, eval { chdir $TAINT } eq '', 'chdir';
  339.     test 66, $@ =~ /^Insecure dependency/, $@;
  340.  
  341.     if ($Config{d_chroot}) {
  342.     test 67, eval { chroot $TAINT } eq '', 'chroot';
  343.     test 68, $@ =~ /^Insecure dependency/, $@;
  344.     }
  345.     else {
  346.     for (67..68) { print "ok $_ # Skipped: chroot() is not available\n" }
  347.     }
  348. }
  349.  
  350. # Some operations using files can't use tainted data.
  351. {
  352.     my $foo = "imaginary library" . $TAINT;
  353.     test 69, eval { require $foo } eq '', 'require';
  354.     test 70, $@ =~ /^Insecure dependency/, $@;
  355.  
  356.     my $filename = "./taintB$$";    # NB: $filename isn't tainted!
  357.     END { unlink $filename if defined $filename }
  358.     $foo = $filename . $TAINT;
  359.     unlink $filename;    # in any case
  360.  
  361.     test 71, eval { open FOO, $foo } eq '', 'open for read';
  362.     test 72, $@ eq '', $@;        # NB: This should be allowed
  363.     test 73, $! == 2 || ($Is_Dos && $! == 22); # File not found
  364.  
  365.     test 74, eval { open FOO, "> $foo" } eq '', 'open for write';
  366.     test 75, $@ =~ /^Insecure dependency/, $@;
  367. }
  368.  
  369. # Commands to the system can't use tainted data
  370. {
  371.     my $foo = $TAINT;
  372.  
  373.     if ($^O eq 'amigaos') {
  374.     for (76..79) { print "ok $_ # Skipped: open('|') is not available\n" }
  375.     }
  376.     else {
  377.     test 76, eval { open FOO, "| $foo" } eq '', 'popen to';
  378.     test 77, $@ =~ /^Insecure dependency/, $@;
  379.  
  380.     test 78, eval { open FOO, "$foo |" } eq '', 'popen from';
  381.     test 79, $@ =~ /^Insecure dependency/, $@;
  382.     }
  383.  
  384.     test 80, eval { exec $TAINT } eq '', 'exec';
  385.     test 81, $@ =~ /^Insecure dependency/, $@;
  386.  
  387.     test 82, eval { system $TAINT } eq '', 'system';
  388.     test 83, $@ =~ /^Insecure dependency/, $@;
  389.  
  390.     $foo = "*";
  391.     taint_these $foo;
  392.  
  393.     test 84, eval { `$echo 1$foo` } eq '', 'backticks';
  394.     test 85, $@ =~ /^Insecure dependency/, $@;
  395.  
  396.     if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe
  397.     test 86, join('', eval { glob $foo } ) ne '', 'globbing';
  398.     test 87, $@ eq '', $@;
  399.     }
  400.     else {
  401.     for (86..87) { print "ok $_ # Skipped: this is not VMS\n"; }
  402.     }
  403. }
  404.  
  405. # Operations which affect processes can't use tainted data.
  406. {
  407.     test 88, eval { kill 0, $TAINT } eq '', 'kill';
  408.     test 89, $@ =~ /^Insecure dependency/, $@;
  409.  
  410.     if ($Config{d_setpgrp}) {
  411.     test 90, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
  412.     test 91, $@ =~ /^Insecure dependency/, $@;
  413.     }
  414.     else {
  415.     for (90..91) { print "ok $_ # Skipped: setpgrp() is not available\n" }
  416.     }
  417.  
  418.     if ($Config{d_setprior}) {
  419.     test 92, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
  420.     test 93, $@ =~ /^Insecure dependency/, $@;
  421.     }
  422.     else {
  423.     for (92..93) { print "ok $_ # Skipped: setpriority() is not available\n" }
  424.     }
  425. }
  426.  
  427. # Some miscellaneous operations can't use tainted data.
  428. {
  429.     if ($Config{d_syscall}) {
  430.     test 94, eval { syscall $TAINT } eq '', 'syscall';
  431.     test 95, $@ =~ /^Insecure dependency/, $@;
  432.     }
  433.     else {
  434.     for (94..95) { print "ok $_ # Skipped: syscall() is not available\n" }
  435.     }
  436.  
  437.     {
  438.     my $foo = "x" x 979;
  439.     taint_these $foo;
  440.     local *FOO;
  441.     my $temp = "./taintC$$";
  442.     END { unlink $temp }
  443.     test 96, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
  444.  
  445.     test 97, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
  446.     test 98, $@ =~ /^Insecure dependency/, $@;
  447.  
  448.     if ($Config{d_fcntl}) {
  449.         test 99, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
  450.         test 100, $@ =~ /^Insecure dependency/, $@;
  451.     }
  452.     else {
  453.         for (99..100) { print "ok $_ # Skipped: fcntl() is not available\n" }
  454.     }
  455.  
  456.     close FOO;
  457.     }
  458. }
  459.  
  460. # Some tests involving references
  461. {
  462.     my $foo = 'abc' . $TAINT;
  463.     my $fooref = \$foo;
  464.     test 101, not tainted $fooref;
  465.     test 102, tainted $$fooref;
  466.     test 103, tainted $foo;
  467. }
  468.  
  469. # Some tests involving assignment
  470. {
  471.     my $foo = $TAINT0;
  472.     my $bar = $foo;
  473.     test 104, all_tainted $foo, $bar;
  474.     test 105, tainted($foo = $bar);
  475.     test 106, tainted($bar = $bar);
  476.     test 107, tainted($bar += $bar);
  477.     test 108, tainted($bar -= $bar);
  478.     test 109, tainted($bar *= $bar);
  479.     test 110, tainted($bar++);
  480.     test 111, tainted($bar /= $bar);
  481.     test 112, tainted($bar += 0);
  482.     test 113, tainted($bar -= 2);
  483.     test 114, tainted($bar *= -1);
  484.     test 115, tainted($bar /= 1);
  485.     test 116, tainted($bar--);
  486.     test 117, $bar == 0;
  487. }
  488.  
  489. # Test assignment and return of lists
  490. {
  491.     my @foo = ("A", "tainted" . $TAINT, "B");
  492.     test 118, not tainted $foo[0];
  493.     test 119,     tainted $foo[1];
  494.     test 120, not tainted $foo[2];
  495.     my @bar = @foo;
  496.     test 121, not tainted $bar[0];
  497.     test 122,     tainted $bar[1];
  498.     test 123, not tainted $bar[2];
  499.     my @baz = eval { "A", "tainted" . $TAINT, "B" };
  500.     test 124, not tainted $baz[0];
  501.     test 125,     tainted $baz[1];
  502.     test 126, not tainted $baz[2];
  503.     my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
  504.     test 127, not tainted $plugh[0];
  505.     test 128,     tainted $plugh[1];
  506.     test 129, not tainted $plugh[2];
  507.     my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
  508.     test 130, not tainted ((&$nautilus)[0]);
  509.     test 131,     tainted ((&$nautilus)[1]);
  510.     test 132, not tainted ((&$nautilus)[2]);
  511.     my @xyzzy = &$nautilus;
  512.     test 133, not tainted $xyzzy[0];
  513.     test 134,     tainted $xyzzy[1];
  514.     test 135, not tainted $xyzzy[2];
  515.     my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
  516.     test 136, not tainted ((&$red_october)[0]);
  517.     test 137,     tainted ((&$red_october)[1]);
  518.     test 138, not tainted ((&$red_october)[2]);
  519.     my @corge = &$red_october;
  520.     test 139, not tainted $corge[0];
  521.     test 140,     tainted $corge[1];
  522.     test 141, not tainted $corge[2];
  523. }
  524.  
  525. # Test for system/library calls returning string data of dubious origin.
  526. {
  527.     # No reliable %Config check for getpw*
  528.     if (eval { setpwent(); getpwent(); 1 }) {
  529.     setpwent();
  530.     my @getpwent = getpwent();
  531.     die "getpwent: $!\n" unless (@getpwent);
  532.     test 142,(    not tainted $getpwent[0]
  533.               and not tainted $getpwent[1]
  534.               and not tainted $getpwent[2]
  535.               and not tainted $getpwent[3]
  536.               and not tainted $getpwent[4]
  537.               and not tainted $getpwent[5]
  538.               and     tainted $getpwent[6] # gecos
  539.               and not tainted $getpwent[7]
  540.           and not tainted $getpwent[8]);
  541.     endpwent();
  542.     } else {
  543.     for (142) { print "ok $_ # Skipped: getpwent() is not available\n" }
  544.     }
  545.  
  546.     if ($Config{d_readdir}) { # pretty hard to imagine not
  547.     local(*D);
  548.     opendir(D, "op") or die "opendir: $!\n";
  549.     my $readdir = readdir(D);
  550.     test 143, tainted $readdir;
  551.     closedir(OP);
  552.     } else {
  553.     for (143) { print "ok $_ # Skipped: readdir() is not available\n" }
  554.     }
  555.  
  556.     if ($Config{d_readlink} && $Config{d_symlink}) {
  557.     my $symlink = "sl$$";
  558.     unlink($symlink);
  559.     symlink("/something/naughty", $symlink) or die "symlink: $!\n";
  560.     my $readlink = readlink($symlink);
  561.     test 144, tainted $readlink;
  562.     unlink($symlink);
  563.     } else {
  564.     for (144) { print "ok $_ # Skipped: readlink() or symlink() is not available\n"; }
  565.     }
  566. }
  567.  
  568. # test bitwise ops (regression bug)
  569. {
  570.     my $why = "y";
  571.     my $j = "x" | $why;
  572.     test 145, not tainted $j;
  573.     $why = $TAINT."y";
  574.     $j = "x" | $why;
  575.     test 146,     tainted $j;
  576. }
  577.  
  578. # test target of substitution (regression bug)
  579. {
  580.     my $why = $TAINT."y";
  581.     $why =~ s/y/z/;
  582.     test 147,     tainted $why;
  583.  
  584.     my $z = "[z]";
  585.     $why =~ s/$z/zee/;
  586.     test 148,     tainted $why;
  587.  
  588.     $why =~ s/e/'-'.$$/ge;
  589.     test 149,     tainted $why;
  590. }
  591.